home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Mops 2.5 / Mops ƒ / Struct < prev    next >
Encoding:
Text File  |  1994-10-08  |  22.8 KB  |  968 lines  |  [TEXT/MSET]
  1. \ Standard data structure classes
  2.  
  3. \ May  91        Added Longword
  4. \ June 91        Reimplemented ordered-col etc. using multiple inheritance
  5. \ May  92        Added obj-array
  6. \ July 92        Fixed OBJ: ObjHandle to use NPTR: instead of PTR:
  7. \                HandleArray now inherits from Obj_array.
  8. \ Dec 92        Replaced UGET: in Int and Byte with new classes UINT and UBYTE.
  9.  
  10.  
  11. :class    LONGWORD  super{ object }    \ Generic superclass for var, handle etc.
  12.  
  13.     4    bytes    data
  14.  
  15. :m CLEAR:    inline{ 0 obj !}    0 ^base !  ;m
  16. :m GET:        inline{ obj @}        ^base @  ;m
  17. :m PUT:        inline{ obj !}        ^base !  ;m
  18. :m ->:        inline{ @ obj !}    chksame  @  put: self  ;m
  19.  
  20. :m PRINT:    ^base @  .  ;m
  21.  
  22. :m CLASSINIT:    clear: self  ;m
  23.  
  24. ;class
  25.  
  26.  
  27. :class    VAR  super{ longword }
  28.  
  29. :m +:        inline{ obj +!}    ^base +!   ;m
  30. :m -:        inline{ obj -!}    ^base -!   ;m
  31. ;class
  32.  
  33.  
  34. :class    INT    super{ object }
  35.  
  36.     2 bytes data
  37.  
  38. :m CLEAR:    inline{ 0 obj w!}    0 ^base w!  ;m
  39. :m GET:        inline{ obj w@x}    ^base w@x  ;m
  40. :m PUT:        inline{ obj w!}        ^base w!  ;m
  41. :m +:        inline{ obj w+!}    ^base w+!  ;m
  42. :m -:        inline{ obj w-!}    ^base w-!  ;m
  43. :m ->:        inline{ w@ obj w!}
  44.         chksame  w@  put: self  ;m
  45.  
  46. :m INT:        ^base w@  makeint  ;m    \ return as toolbox int
  47.  
  48. :m PRINT:    ^base w@  .  ;m
  49.  
  50. :m CLASSINIT:    clear: self  ;m
  51.  
  52. ;class
  53.  
  54. :class  UINT  super{ int }
  55.  
  56. :m GET:    inline{ obj w@}  ^base w@  ;m
  57.  
  58. ;class
  59.  
  60.  
  61. :class    BYTE    super{ object }
  62.  
  63.     1 bytes data
  64.  
  65. :m CLEAR:    inline{ 0 obj c!}    0 ^base c!  ;m
  66. :m GET:        inline{ obj c@x}    ^base c@x  ;m
  67. :m PUT:        inline{ obj c!}        ^base c!  ;m
  68. :m ->:        inline{ c@ obj c!}    chksame  c@  put: self  ;m
  69.  
  70. :m PRINT:    ^base c@  .  ;m
  71.  
  72. :m CLASSINIT:    clear: self  ;m
  73.  
  74. ;class
  75.  
  76.  
  77. :class  UBYTE  super{ byte }
  78.  
  79. :m GET:        inline{ obj c@}    ^base c@  ;m
  80.  
  81. ;class
  82.  
  83.  
  84. :class    BOOL    super{ byte }
  85.  
  86. :m PUT:        inline{ 0<> obj c!}        0<>  ^base c!  ;m
  87. :m SET:        inline{ true obj c!}    true  ^base c!  ;m
  88.  
  89. :m PRINT:    get: self  IF  ." true"  ELSE  ." false"  THEN  ;m
  90.  
  91. ;class
  92.  
  93.  
  94. \ Handle class can store handles to relocatable heap blocks.
  95. \ It would be nice to store the length too, but this class is used
  96. \ for handles in toolbox records so we can't.  Not here at least.
  97.  
  98.     0    value    RELCNT        \ For testing - counts release: msgs
  99.                             \ to make sure we're releasing everything
  100.  
  101. :class    HANDLE    super{ longword }
  102.  
  103. :m PTR:        \ Dereferences handle to get pointer.  Trap if nil.
  104.     inline{ obj @ @}    ^base @ @  ;m
  105.  
  106. :m NPTR:        \ Dereferences handle and masks with SAmask so we can
  107.                 \ use the pointer numerically.
  108.     ^base @ @ SAmask and  ;m
  109.  
  110. :m RELEASE:        \ Deallocates the heap block, if allocated.
  111.     1 ++> relCnt  killH  ;m
  112.  
  113. :m CLEAR:    nilH  ^base !  ;m    \ We hope we know what we're doing.
  114.  
  115. :m NIL?:        \ ( -- b )
  116.     get: self  nilH =  ;m
  117.  
  118. :m SETSIZE:    \ ( size -- }
  119.     setHsz  0= ?error 166  ;m
  120.  
  121. :m SIZE:        \ ( -- size )  Gets current size.
  122.     getHSz  ;m
  123.  
  124. :m NEW:        \ ( size -- )
  125.     newH  0= ?error 166  ;m
  126.  
  127. :m LOCK:    lok    ;m
  128. :m UNLOCK:    unlok  ;m
  129.  
  130. :m GETSTATE:  ( -- state )    HgetSt  ;m
  131. :m SETSTATE:  ( state -- )    HsetSt  ;m
  132.  
  133. :m LOCKED?:   ( -- b )        HgetSt  $ 80 and  0<>  ;m
  134.  
  135. :m MOVEHI:    MvHHi  drop ( errors don't really matter here )  ;m
  136.  
  137. :m ->:        \ ( ^hdl -- )  Copies passed-in handle's heap data to self.
  138.     chkSame  copyH  ?error 167  ;m
  139.  
  140. :m PRINT:
  141.     & $ emit  ^base @  u.h  ;m    \ We assume a print: of a handle is more
  142.                                 \  useful in hex.
  143.  
  144. :m CLASSINIT:    clear: self  ;m        \ Initially nil
  145.  
  146. ;class
  147.  
  148.  
  149. \ OBJHANDLE is a handle that points to an object in the heap.
  150.  
  151. :class    OBJHANDLE  super{ handle }
  152.  
  153. :m OBJ:        moveHi: self  lock: self  nptr: self  >obj  ;m
  154.  
  155.     \ Note: if we're going to bind to a heap-based object,
  156.     \ the handle MUST be locked while we do so - anything
  157.     \ may happen before the method returns!!  Thus we make the
  158.     \ obj: method do a moveHi and lock.  But remember to unlock
  159.     \ the handle eventually!  (Unless you're releasing it, of course.)
  160.  
  161. :m NEWOBJ:  ( #els ) { ^class -- }
  162.         \ Usage:  5  ['] someClass  newObj: someHndl
  163.  
  164.     ^class  cl>len  8 +  new: self
  165.     ^class  obj: self  make_obj  unlock: self  ;m
  166.  
  167. :m RELEASEOBJ:
  168.     nil?: self  ?EXIT
  169.     obj: self  release: []  release: super  ;m
  170.  
  171. :m RELEASE:    releaseObj: self  ;m        \ Standard destructor name.
  172.  
  173.     \ Note: we define both release: and releaseObj: so that in classes
  174.     \ HandleArray and HandleList we can distinguish between releasing the
  175.     \ current object and releasing the whole lot.  Release: is of course
  176.     \ overridden in those two classes to release the entire structure.
  177.  
  178. :m PRINT:
  179.     print: super  4 spaces  ." object: "
  180.     nil?: self
  181.     if    ." (none)"
  182.     else    print: [ obj: self ]  unlock: self
  183.     then   ;m
  184.  
  185. :m DUMP:
  186.     dump: super  cr
  187.     ." object: "
  188.     nil?: self
  189.     if    ." (none)"
  190.     else    dump: [ obj: self ]  unlock: self
  191.     then   ;m
  192.  
  193. ;class
  194.  
  195. :class    PTR     super{ longword }
  196.  
  197. :m RELEASE:        \ Deallocates the heap block, if allocated.
  198.     killP  ;m
  199.  
  200. :m NEW:   ( len -- )    newP  0= ?error 121  ;m
  201.  
  202. :m NIL?:   ( -- b )        ^base @  nilP =  ;m
  203.  
  204. :m CLEAR:    nilP  ^base !  ;m        \ We hope we know what we're doing.
  205.  
  206. :m CLASSINIT:    clear: self  ;m        \ Initially nil
  207.  
  208. ;class
  209.  
  210.  
  211. \ DICADDR is a relocatable dictionary address class - use to store
  212. \ non-executable dictionary addresses.
  213.  
  214. :class     DICADDR  super{ longword }
  215.  
  216. :m GET:        ^base  @abs    ;m
  217. :m PUT:        ^base  reloc!    ;m
  218.  
  219. :m PRINT:    get: self  .id  ;m
  220.  
  221. :m CLASSINIT:    ['] null  put: self  ;m
  222.  
  223. ;class
  224.  
  225.  
  226. \ X-ADDR is an executable dictionary address class.  The only significant
  227. \ difference to DicAddr is that there is an Exec: method.
  228. \ But if we ever have to separate code and data, having a separate class
  229. \ could prove very useful.  An x-addr is the same as a Mops execution token.
  230.  
  231. :class    X-ADDR    super{ object }
  232.  
  233.     4    bytes    data
  234.  
  235. :m EXEC:    inline{ obj ex}    ^base @abs  execute  ;m
  236.  
  237. :m GET:        ^base  @abs    ;m
  238. :m PUT:        ^base  reloc!   ;m
  239.  
  240. :m CLASSINIT:    ['] null  put: self  ;m
  241.  
  242. ;class
  243.  
  244.  
  245. \        ============= Arrays ===============
  246.  
  247. : ?#XTS    \ ( n1 n2 -- )  Used to check that the right
  248.         \ number of stacked cfas is being passed in.
  249.     <>  ?error 171  ;    \ "Wrong number of cfas"
  250.  
  251.  
  252. \ Class INDEXED-OBJ is the generic superclass for all arrays.  Here we define
  253. \ the general indexed methods, which apply regardless of indexed width.
  254.  
  255. :class    INDEXED-OBJ  super{ object }
  256.  
  257. :m ^ELEM:    ^elem  ;m
  258.  
  259. :m LIMIT:    limit  ;m
  260.  
  261. :m WIDTH:    idxbase  6 -  w@  ;m
  262.  
  263. :m IXADDR:    idxbase  ;m
  264.  
  265. :m CLEARX:    \ Erases indexed area.
  266.     idxbase  limit  width: self  *  erase  ;m
  267.  
  268. ;class
  269.  
  270.  
  271. \ ARRAY is the basic 4-byte cell array.
  272.  
  273. :class    ARRAY  super{ indexed-obj }  4 indexed
  274.  
  275. :m AT:  ( index -- n )        inline{ ix @}    ^elem4  @    ;m
  276. :m TO:  ( n index -- )        inline{ ix !}    ^elem4  !    ;m
  277. :m +TO:  ( n index -- )        inline{ ix +!}    ^elem4  +!    ;m
  278. :m -TO:  ( n index -- )        inline{ ix -!}    ^elem4  -!    ;m
  279. :m ^ELEM:  ( idx -- addr )    inline{ ix}    ^elem4    ;m
  280.  
  281. :m FILL:        \ ( value -- )  Fills all elements with value.
  282.     idxbase  limit 4*  bounds
  283.     ?do  dup  i !  4 +loop  drop  ;m
  284.  
  285. :m WIDTH:    4  ;m        \ Faster than the default in Indexed-obj.
  286.  
  287. :m GETELEM:    \ ( addr -- n )  Fetches one element at addr - saves indexing
  288.         \        step if addr is known.
  289.     @  ;m
  290.  
  291. ;class
  292.  
  293.  
  294. \ X-ARRAY can execute its elements.
  295.  
  296. :class    X-ARRAY  super{ array }
  297.  
  298. :m TO:  ( index -- )    ^elem: super  reloc!  ;m
  299.  
  300. :m EXEC:  ( index -- )
  301.     inline{ ix ex}    ^elem: self  @abs  execute  ;m
  302.  
  303. :m FILL:        \ ( xt -- )
  304.     limit nif  drop  exit  then    \ Out if no elements
  305.     idxbase  tuck  reloc!    @  fill: super  ;m
  306.  
  307. :m PUT:            \ ( xt0 ... xt(N-1) N -- )
  308.     limit  0EXIT                \ Out if no elements
  309.     false -> relocChk?            \ May get used in instantiating exported objs
  310.     limit ?#xts
  311.     idxbase  dup  limit 1-  4*  +
  312.     do  i reloc!  -4 +loop
  313.     true -> relocChk?  ;m
  314.  
  315. :m ACTIONS:        \ A synonym for put:.  A more appropriate name to use in
  316.                 \ sub-classes such as dialogs.
  317.     put: self  ;m
  318.  
  319. private
  320.  
  321. :m PrintNxts:    \ ( n -- )
  322.     0 ?do  i ^elem: self  @abs  cr .id  loop  ;m
  323.  
  324. public
  325.  
  326. :m PRINT:        limit  printNxts: self  ;m
  327.  
  328. :m CLASSINIT:    ['] null  fill: self  ;m
  329.  
  330. ;class
  331.  
  332.  
  333. \ SEQUENCE is a generic superclass for classes which have multiple items which
  334. \ frequently need to be looked at in sequence.  At present the main function of
  335. \ Sequence is to implement the EACH: method, which makes it very simple to
  336. \ deal with each element.  The usage is
  337. \
  338. \    BEGIN  each: <obj>  WHILE  <do something to the element>  REPEAT
  339. \
  340. \ Sequence can be multiply inherited with any class which implements the
  341. \ FIRST?: and NEXT?: methods.  The actual implementation details are quite
  342. \ irrelevant, as long as these methods are supported.
  343.  
  344. \ But note that any class using Sequence should not appear in a record, since
  345. \ we must late bind to self, so a class pointer must be present.
  346.  
  347. :class    SEQUENCE    super{ object }        general
  348.  
  349. record
  350. {    var    NXT_XT
  351.     var    ^SELF
  352. }
  353.  
  354. :m EACH:        \ ( -- (varies) T  |  -- F )
  355.     get: nxt_xt
  356.     NIF                                \ First time in:
  357.         first?: [self]  0dup  0EXIT
  358.         self  bind_with next?:        \ Late-bind to next?: and cache
  359.         put: nxt_xt  put: ^self        \  the xt for the loop
  360.         true                        \ Yes, we've got the 1st element
  361.     ELSE                            \ Subsequent time in:
  362.         get: ^self  get: nxt_xt  ex-method        \ Call next?: method (cached)
  363.         IF  true  ELSE  clear: nxt_xt  false  THEN
  364.     THEN  ;m
  365.  
  366. :m UNEACH:    \ Use to terminate an EACH: loop before the end.
  367.     clear: nxt_xt  ;m
  368.  
  369. ;class
  370.  
  371.  
  372. 0    value    LASTSUP
  373. 0    value    LASTSUPADDR
  374.  
  375. : REMOVELASTSUPER  { ^class \ infa -- }
  376.     ^class ifa displace  -> infa
  377.     BEGIN  infa @ 0>  NWHILE  infa ^nextivar  -> infa
  378.     REPEAT
  379.     BEGIN
  380.         4 ++> infa
  381.         infa @
  382.     NUNTIL
  383.     4 --> infa
  384.     infa -> lastSupAddr
  385.     infa @  -> lastSup
  386.     0 infa !  ;
  387.             
  388. : RESTORELASTSUPER
  389.     lastSup lastSupAddr !  ;
  390.  
  391.  
  392. \ OBJ_ARRAY is a generic superclass which makes it easy to generate an array
  393. \ of objects of a given class.  Just define a new class which multiply
  394. \ inherits from the given class (or classes) and OBJ_ARRAY (which must come
  395. \ last).  This will add an indexed section to each object of the new class,
  396. \ with elements wide enough to contain objects of the original class.  Then
  397. \ SELECT: "switches in" the selected element to be the "current" element,
  398. \ and all the normal methods  of the class can then be used.
  399. \ The implementation is general rather than brilliantly fast.  If switching
  400. \ between elements is really a performance concern, you could override
  401. \ SELECT: - especially if you know the element width.  But note, we do
  402. \ assume the elements are aligned.
  403.  
  404. :class  OBJ_ARRAY  super{ indexed-obj sequence }    32767 indexed
  405.             \ The 32767 signals that the real indexed width is to be
  406.             \  taken from the other superclass(es).
  407.  
  408. record{  int  CURRENT  }
  409.  
  410. :m CURRENT:
  411.     get: current  ;m
  412.  
  413. :m SELECT:  { idx \ datalen slf -- }
  414.     idx  get: current =  ?EXIT                        \ out if nothing to do
  415.     width: self  -> datalen   self -> slf            \ set up
  416.     slf  get: current  ^elem  datalen  aligned_move    \ switch out previous
  417.     idx  put: current
  418.     idx ^elem  slf  datalen  aligned_move  ;m        \ switch in new
  419.  
  420. :m FIRST?:
  421.     limit NIF  false  EXIT  THEN
  422.     0  select: self  true  ;m
  423.  
  424. :m NEXT?:
  425.     get: current 1+  limit  >=  IF  false  EXIT  THEN
  426.     get: current 1+  select: self  true  ;m
  427.     
  428.  
  429. :m PRINTALL:    \ Sends PRINT: to all elements
  430.     get: current
  431.     BEGIN  each: self  WHILE  print: [self]  REPEAT
  432.     select: self  ;m
  433.  
  434. (*
  435. We need to initialize all the elements.  Element 0 has been initialized
  436. already, by the time we get classinit: sent here, since we're the last
  437. superclass.  We could select each element and send deep_classinit:, but
  438. it's a bit tricky getting the right class to use.  Instead we'll just
  439. copy element 0 to the other elements, which will usually be good enough.
  440. *)
  441.  
  442. :m CLASSINIT:  { \ dln slf -- }
  443.     width: self  -> dln   self -> slf            \ set up
  444.     limit  1        \ note: elt 0 has had classinit: already!
  445.     ?DO
  446.            slf  i ^elem  dln  aligned_move
  447.     LOOP
  448. ;m
  449.  
  450. ;class
  451.  
  452.  
  453. \ (PHlist) is a superclass for HandleList and PtrList, mainly aimed at
  454. \ factoring out common code.  It's really only meant for internal use.
  455.  
  456. :class (PHlist)  super{ sequence }
  457.  
  458. record
  459. {    handle    THELIST
  460.     var        SIZE
  461.     var        POS
  462. }
  463.  
  464. private
  465.  
  466. :m  (SEL):    \ ( n -- )  n is offset into theList, NOT an index.
  467.     self @  ptr: theList  get: pos +  !        \ switch out previous
  468.     put: pos
  469.     ptr: theList  get: pos  +  @  self !    \ switch in new
  470. ;m
  471.  
  472. public
  473.  
  474. :m ADD:  { addMe \ whr ^class -- }
  475.     get: size  -> whr
  476.     whr
  477.     NIF    nil?: theList
  478.         IF        80  new: theList        \ Give it room to play with
  479.         ELSE    80  setsize: theList
  480.         THEN
  481.     THEN
  482.     whr cell+  dup  setsize: theList  put: size
  483.     whr  (sel): self
  484.     addMe  self !
  485. ;m
  486.  
  487.  
  488. :m REMOVE:  { \ whr cnt -- }        \ Completely removes the current element.
  489.     ptr: theList  get: pos  +  -> whr
  490.     1cell  -: size  get: size  get: pos  -  -> cnt
  491.     cnt IF  whr cell+  whr  cnt  move  THEN
  492.                     \ note: can't use aligned_move since it's a move down,
  493.                     \ and overlaps
  494.     get: pos  cell-  0 max  put: pos
  495.     ptr: theList  get: pos  +
  496.     ptr: theList  get: pos  +  @  self !    \ switch in new current elt
  497.     get: size  NIF  release: theList  THEN  ;m
  498.  
  499.  
  500. :m SELECT:    \ ( n -- )
  501.     4*  0  get: size cell-  within? not  ?error 134
  502.     (sel): self  ;m
  503.  
  504. :m SELECTLAST:
  505.     get: size  cell-  (sel): self  ;m
  506.  
  507. :m CURRENT:    get: pos  4/  ;m
  508.  
  509. :m SIZE:    get: size 4/  ;m
  510.  
  511. \ The next two methods are needed by EACH:, but may be called directly as well.
  512. \ Note that NEXT?:  ASSUMES that the list is allocated in the heap and that a
  513. \ valid element is selected as the current element.  EACH: ensures this,
  514. \ since if FIRST?: returns false, NEXT?: is never called.  But if you call
  515. \ it directly, make sure this condition holds.
  516.  
  517. :m FIRST?:    \ ( -- n T | -- F )
  518.     nil?: theList  IF  false  EXIT  THEN
  519.     0 (sel): self  self @  true  ;m
  520.  
  521. :m NEXT?:  { \ nxt -- n T | -- F }
  522.     get: pos  cell+  -> nxt
  523.     nxt  get: size  >= IF  false  EXIT  THEN
  524.     nxt (sel): self  self @  true  ;m
  525.  
  526.  
  527. :m DUMPALL:
  528.     nil?: theList IF  ." (not open)"  EXIT  THEN
  529.     dump: super  cr  ." current: "  current: self  dup .
  530.     cr ." elements: "  cr
  531.     BEGIN  each: [self]  WHILE  dump: [self]  REPEAT
  532.     select: self  ;m
  533.  
  534. :m PRINTALL:
  535.     nil?: theList IF  ." (not open)"  EXIT  THEN
  536.     get: pos
  537.     BEGIN  each: self  WHILE  print: [self]  cr  REPEAT
  538.     (sel): self  ;m
  539.  
  540. ;class
  541.  
  542.  
  543. \ HANDLEARRAY and HANDLELIST are for the implementation of collections
  544. \ of heap-based objects.  HandleArray has normal array properties, and
  545. \ thus a definite length.  HandleList, however, allows the number of
  546. \ elements to grow arbitrarily large.  Use HandleList if you need an
  547. \ indefinite number of elements, and if indexing isn't so important.
  548. \ HandleArray also includes methods to allow the array to be used as a
  549. \ stack - needed for FileList.
  550.  
  551. :class    HANDLEARRAY  super{ objHandle  array  obj_array }
  552.  
  553. record
  554. {    int    size  }
  555.  
  556. :m SIZE:        get: size  ;m
  557. :m SETSIZE:        put: size  ;m
  558.  
  559. :m RELEASE:
  560.     get: size  0  ?DO
  561.         i select: self  releaseObj: self
  562.     LOOP  ;m
  563.  
  564. :m PUSH:        \ ( hdl -- )
  565.     get: size  limit  >=  ?error 137
  566.     get: size  select: self  1 +: size
  567.     put: super  ;m
  568.  
  569. private
  570. :m (TOP):
  571.     get: size  dup
  572.     IF    1-  select: self
  573.     ELSE    drop  clear: current
  574.     THEN  ;m
  575. public
  576.  
  577. :m TOP:
  578.     get: size  0= ?error 136  (top): self  ;m
  579.  
  580. :m DROP:
  581.     get: size  dup  0= ?error 136
  582.     1-  select: self  releaseObj: self
  583.     1 -: size  (top): self  ;m
  584.  
  585. :m PUSHNEWOBJ:
  586.     0 push: self  newObj: self  ;m
  587.  
  588. :m CLEARX:    nilH  fill: self  ;m
  589.  
  590. :m  CLASSINIT:    clearX: self  clear: self  ;m
  591.  
  592. ;class
  593.  
  594.  
  595. \ HANDLELIST allows the implementation of a list of heap-based objects.
  596. \ Unlike HANDLEARRAY, the list can be of indefinite length.  We use a heap
  597. \ block to store the handles to the objects contiguously, rather than have
  598. \ a separate block for each handle and link them together.  This saves on
  599. \ memory overhead and reduces the number of memory manager calls.  It also
  600. \ reflects the assumption that insertions and deletions into the middle of
  601. \ the list will be infrequent, as these could be more inefficient than with
  602. \ a linked scheme.  We expect that elements will normally be added to the
  603. \ end, and probably not removed at all, or not very often.
  604.  
  605.  
  606. :class  HANDLELIST  super{ objHandle (PHlist) }
  607.  
  608. \ FIRST?: and NEXT?:, needed for the EACH: construction, are overridden here
  609. \ since if the next element exists we return the object address as well as
  610. \ the True.  We also need to unlock the previous objHandle when we step
  611. \ to the next one.
  612.  
  613. :m SIZE:    \ We're overriding here since objHandle has a size: method
  614.             \  which isn't really useful here
  615.     size: super> (PHlist)  ;m
  616.  
  617. :m FIRST?:    \ ( -- ^obj T | -- F )
  618.     first?: super  NIF  false  EXIT  THEN
  619.     drop  obj: self  true  ;m
  620.  
  621. :m NEXT?:  { \ nxt -- ^obj T | -- F }
  622.     unlock: super
  623.     next?: super  NIF  false  EXIT  THEN
  624.     drop  obj: self  true  ;m
  625.  
  626.  
  627. :m NEWOBJ:    \ ( ^class -- )
  628.     nilH  add: super> (PHlist)
  629.     newObj: super  ;m
  630.  
  631. :m REMOVEOBJ:            \ Completely removes the current element.
  632.     releaseObj: super  remove: super  ;m
  633.  
  634. :m RELEASE:
  635.     BEGIN  each: self  WHILE  drop  releaseObj: super  REPEAT
  636.     release: theList
  637.     clear: pos  clear: size  ;m
  638.  
  639. :m DUMPALL:
  640.     nil?: theList if  ." (not open)"  EXIT  THEN
  641.     dump: super  cr  ." current: "  get: pos  dup 4/ .
  642.     cr ." elements: "  cr
  643.     BEGIN  each: self  WHILE  dump: []  REPEAT
  644.     (sel): self   ;m
  645.  
  646. :m PRINTALL:
  647.     nil?: theList if  ." (not open)"  EXIT  THEN
  648.     get: pos
  649.     BEGIN  each: self  WHILE  print: []  cr  REPEAT
  650.     (sel): self  ;m
  651.     
  652. ;class
  653.  
  654.  
  655. :class PTRLIST  super{ ptr (PHlist) }
  656.  
  657. ;class
  658.  
  659.  
  660. \            ============== Collections ================
  661.  
  662. \ Collections are ordered lists with a current size.  We implement them by
  663. \ multiply inheriting the generic (COL) class with the array class of the
  664. \ appropriate width.  We use a few tricks to avoid late binding to self
  665. \ in loops.
  666.  
  667. :class    (COL)  super{ object }
  668.  
  669. record
  670. {    int    SIZE    }            \ # elements in list
  671.  
  672. :m SIZE:    \ ( -- cursize )  Returns #elements currently in list
  673.      inline{ get: size}  get: size  ;m
  674.  
  675. :m CLEAR:    \ Set to list to null
  676.     clear: size   clearx: [self]  ;m
  677.  
  678. :m ADD:        \ ( val -- )  add value to end of list
  679.     get: size  limit  >=  ?error 137
  680.     get: size  to: [self]  1 +: size  ;m
  681.  
  682. :m LAST:        \ ( -- val )  Returns contents of end of list
  683.     get: size  dup 0=  ?error 136
  684.     1-  at: [self]  ;m
  685.  
  686. :m REMOVE:  { indx \ cnt wid addr -- }    \ Removes the element at index
  687.     get: size  indx -  1-  -> cnt
  688.     cnt 0<  ?error 136
  689.     width: [self]  -> wid
  690.     indx  ^elem: [self]  -> addr
  691.     1 -: size
  692.     cnt  0exit
  693.     addr wid +  addr  cnt wid *  move  ;m
  694.  
  695. :m INDEXOF:  { val \ ^self ^getelem wid addr -- indx T  | -- F }
  696.                 \ Finds a value in a collection.
  697.     self  bind_with getelem:  -> ^getelem  -> ^self
  698.     width: [self]  -> wid  idxbase -> addr
  699.     false  get: size  0
  700.     ?do
  701.         addr  ^self ^getelem  ex-method
  702.         val =  if  drop  i  true  leave  then
  703.         wid ++> addr
  704.     loop  ;m
  705.  
  706. :m PRINT:
  707.     get: size  0  ?do  i  at: [self]  cr .  loop  ;m
  708.  
  709. :m DUMP:
  710.     dump: super  ." size: "  get: size .  ;m
  711.  
  712. ;class
  713.  
  714.  
  715. \ Ordered-Collection is a collection of 4-byte cells.
  716.  
  717. :class    ORDERED-COL    super{ (col) array }
  718. ;class                        \ That's all, folks!!
  719.  
  720.  
  721. \ X-COL is a collection of execution tokens.
  722.  
  723. :class    X-COL    super{  (col)  x-array  }
  724.  
  725. :m  REMOVEXT:    \ ( xt -- )
  726.     false -> relocChk?  pad reloc!  true -> relocChk?
  727.     pad @  indexof: self  0EXIT
  728.     remove: self  ;m
  729.  
  730. :m  PRINT:
  731.     get: size  printNXts: self  ;m
  732.  
  733. ;class
  734.  
  735.  
  736.  
  737.  
  738. :class    DIC-MARK    super{ object }
  739.  
  740. #threads    array    LINKS
  741. record {    int        CURRENT    }
  742.  
  743. private
  744.  
  745. :m  SETC:  { \ addr index -- index }
  746.     0 -> addr  0 -> index
  747.     #threads FOR
  748.         i at: links  dup addr u>
  749.         IF  -> addr  i -> index  ELSE  drop  THEN
  750.     NEXT
  751.     index  put: current  ;m
  752. public
  753.  
  754. :m CURRENT:
  755.     get: current  at: links  ;m
  756.  
  757. :m SET:  { addr -- }
  758.     #threads FOR
  759.         context  i  2 <<  +  displace
  760.         BEGIN    dup addr u>            \ We're 32-bit clean around here!
  761.         WHILE    displace
  762.         REPEAT
  763.         i to: links
  764.     NEXT
  765.     setc: self  ;m
  766.  
  767. :m SETTOTOP:    big#  set: self  ;m
  768.  
  769. :m NEXT:  { \ lfa -- lfa }
  770.     get: current  at: links
  771.     dup -> lfa  dup  0EXIT
  772.     displace  get: current  to: links
  773.     setc: self  lfa  ;m
  774.  
  775. ;class
  776.  
  777. dic-mark    TheMARK
  778.  
  779.  
  780. \         ========== Resource support ===========
  781.  
  782. :class    RESOURCE  super{ handle }
  783.  
  784. record
  785. {    var    RESTYPE
  786.     int    ID
  787. }
  788.  
  789. :m SET:        \ ( type id# -- )
  790.     put: ID  put: resType   ;m
  791.  
  792. :m GETNEW:
  793.     get: resType  get: ID  getRes  dup
  794.     NIF                            \ Failed - display type and ID
  795.         cr  addr: resType  4  type  2 spaces
  796.         get: ID  .  170 die        \ Couldn't find this resource
  797.     THEN
  798.     put: super  ;m
  799.  
  800. :m GETXSTR:  { idx \ addr -- addr len }
  801.     getnew: self
  802.     ptr: self  -> addr
  803.     addr w@ 1-  idx min  -> idx
  804.     2 ++> addr
  805.     idx 0 ?DO  addr count +  -> addr  LOOP
  806.     addr count   ;m
  807.  
  808. ;class
  809.  
  810. \                ====================================
  811.  
  812. \                        SOME UTILITY WORDS
  813.  
  814. \                ====================================
  815.  
  816. \ Any special run-time initialization can be done conveniently by adding
  817. \ the appropriate words to the x-col INIT_ACTIONS.  These words will be
  818. \ executed on startup via EXTRA_INITS, right after OBJINIT.
  819.  
  820.     8    x-col    INIT_ACTIONS
  821.  
  822. : X        size: init_actions  0  ?DO  i exec: init_actions  LOOP  ;
  823.  
  824. ' x  -> extra_inits
  825.  
  826.  
  827. : SCREENBITS    \ ( -- l t r b )
  828.                 \ Gets dimension coordinates of host machine's display.
  829.     $ 904 @ @  116 -        \ **** warning - low mem global ref'd
  830.     dup    @ unpack
  831.     rot 4+ @ unpack  ;
  832.  
  833.  
  834. : CHKKEY
  835.     cr     type# 189            \ "paused - <space> to continue..."
  836.     cr                        \ 01Feb94 DBH  Add cr.  Better for TW.
  837.     (key)  cr  0 -> out  bl =  nif  cr decimal abort  then  ;
  838.  
  839.  
  840. : ?P
  841.     sleepticks  0 -> sleepticks
  842.     ?terminal
  843.     swap -> sleepticks
  844.     NIF  pause  EXIT  THEN        \ No key hit - just do default PAUSE
  845.     (key) drop  chkKey  ;
  846.  
  847. : P
  848.     sleepticks  0 -> sleepticks
  849.     ?terminal  drop
  850.     -> sleepticks  ;
  851.  
  852. ' p        -> pause            \ This will be improved when Events is loaded
  853. ' ?p    -> ?pause
  854.  
  855.  
  856. : WORDS  { \ svbase svcurs n -- }
  857.     setToTop: theMark  0 -> out  0 -> n
  858.     base -> svbase  hex  curs -> svcurs  -curs  cr
  859.     BEGIN
  860.         next: theMark
  861.         ?dup
  862.     WHILE
  863.         1 ++> n
  864.         out 60 >
  865.         if  cr  0 -> out  ?pause  then
  866.         link> dup  6 .r  2 spaces  .id  space
  867.         20  out 20 mod -  spaces
  868.     REPEAT
  869.     svbase -> base
  870.     cr ." No of words: "  n .  cr
  871.     svcurs -> curs  ;
  872.  
  873.  
  874. false    value    ENDTRAV?    \ May be set from within a trav handler
  875.                 \ to terminate the trav
  876.  
  877. : (TRAV)  { theWord parm -- }
  878.     false -> endTrav?
  879.     BEGIN
  880.         next: theMark
  881.         ?dup  0EXIT
  882.         link>  parm  theWord execute
  883.         endTrav?
  884.     UNTIL  ;
  885.  
  886. : TRAV    \ ( xt parm -- )
  887.         \ Traverses the dictionary, passing each xt and the parm
  888.         \ to the passed-in proc.
  889.  
  890.     setToTop: theMark  (trav)  ;
  891.  
  892. : TRAV-FROM    \ ( xt parm addr -- )
  893.             \ As for TRAV, but starts from the first word whose lfa is
  894.             \ below or at the given address.
  895.  
  896.     set: theMark  (trav)  ;
  897.  
  898.  
  899. \                =============== Dump ==================
  900.  
  901. \ This used to be in the Util module.  But sometimes the loading of that
  902. \ module could cause the address of what we wanted to dump to change.
  903.  
  904.     0    value    DADDR
  905.     0    value    DLEN
  906.  
  907. : U.R
  908.     >r 0 <# #s #>  r> over - spaces  type  ;
  909.  
  910. : dot4    0 <#  # # # #  #>    type  space  ;
  911.  
  912. : D.4    ( addr len -- )  bounds do  i w@  dot4  2 +loop  ;
  913.  
  914. : EMIT.        \ ( c -- )
  915.     127 and  bl 126 within?  nif  drop  & .  then  emit  ;
  916.  
  917. : DLN        \ ( addr -- )
  918.     cr  dup  8 u.r  2 spaces
  919.     dup ( addr )  8 2dup d.4 space  +  8 d.4 space
  920.     16  bounds DO  i c@ emit.  LOOP  ;
  921.  
  922.  
  923. : ?.N        \ ( n1 n2 -- n1 )
  924.     2dup = if  ." \/"  drop  else  1 .r space  then  ;
  925.  
  926. : ?.A        \ ( n1 n2 -- n1 )
  927.     2dup = if  drop  & V  emit  else  1 .r  then  ;
  928.  
  929. : .HEAD        \ ( addr len -- addr' len' )
  930.     swap  dup -16 and  swap 15 and  cr  10 spaces
  931.      8 0 DO  i ?.n   i 1+ ?.n  space  2 +LOOP  space
  932.     16 8 DO  i ?.n   i 1+ ?.n  space  2 +LOOP  space
  933.     16 0 DO  i ?.a  LOOP   rot +  ;
  934.  
  935. :f DUMP  { addr len \ svBase svCurs -- }
  936.     base -> svBase  hex  curs -> svCurs  -curs
  937.     addr len  .head
  938.     2dup  -> dLen  -> dAddr        \ Save for DN
  939.     bounds  DO  i dln  ?pause  16 +LOOP  cr
  940.     svbase -> base  svCurs -> curs  ;f
  941.  
  942. : DN        \ Dump next
  943.     dLen ++> dAddr  dAddr dLen dump  ;
  944.  
  945. : .W    '  >name 200 dump  ;
  946.  
  947.  
  948. <" String
  949.  
  950. \ Testing:
  951.  
  952. +echo
  953.  
  954. :class VArr super{ var obj_array }
  955. ;class
  956.  
  957. 6 varr OA
  958.  
  959. handleList HL
  960.  
  961. key!
  962.  
  963. : h1 ." hello"  ;
  964. : h2 ." hi there!"  ;
  965.  
  966. 3 x-array xx
  967. xts{ h1 h2 h1 } put: xx
  968.